home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / top.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-10  |  20.7 KB  |  602 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;  top.lsp
  21. ;;;;
  22. ;;;;  Top-level loop, break loop, and error handlers
  23. ;;;;
  24. ;;;;  Revised on July 11, by Carl Hoffman.
  25.  
  26.  
  27. (in-package 'lisp)
  28.  
  29. (export '(+ ++ +++ - * ** *** / // ///))
  30. (export '(break warn))
  31. (export '*break-on-warnings*)
  32. (export '*break-enable*)
  33.  
  34. (in-package 'system)
  35.  
  36. (export '*break-readtable*)
  37. (export '(loc *debug-print-level*))
  38.  
  39. (export '(vs ihs-vs ihs-fun frs-vs frs-bds frs-ihs bds-var bds-val super-go))
  40.  
  41. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  42. (defvar *command-args* nil)
  43. (defvar +)
  44. (defvar ++)
  45. (defvar +++)
  46. (defvar -)
  47. (defvar *)
  48. (defvar **)
  49. (defvar ***)
  50. (defvar /)
  51. (defvar //)
  52. (defvar ///)
  53.  
  54. (defvar *lisp-initialized* nil)
  55.  
  56. (defvar *quit-tag* (cons nil nil))
  57. (defvar *quit-tags* nil)
  58. (defvar *break-level* '())
  59. (defvar *break-env* nil)
  60. (defvar *ihs-base* 1)
  61. (defvar *ihs-top* 1)
  62. (defvar *current-ihs* 1)
  63. (defvar *frs-base* 0)
  64. (defvar *frs-top* 0)
  65. (defvar *break-enable* t)
  66. (defvar *break-message* "")
  67.  
  68. (defvar *break-on-warnings* nil)
  69.  
  70. (defvar *break-readtable* nil)
  71.  
  72. (defvar *top-level-hook* nil)
  73.  
  74. (defvar *top-eof* (cons nil nil))
  75. (defvar *no-prompt* nil)
  76. (defun top-level ()
  77.   (let ((+ nil) (++ nil) (+++ nil)
  78.         (- nil) 
  79.         (* nil) (** nil) (*** nil)
  80.         (/ nil) (// nil) (/// nil))
  81.     (setq *lisp-initialized* t)
  82.     (catch *quit-tag*
  83.       (let ((tem (string-concatenate *system-directory*
  84.                      "sys-init.lsp")))
  85.     (when (probe-file tem)
  86.       (load tem :verbose nil))
  87.     (cond (*multiply-stacks* (setq *multiply-stacks* nil))
  88.           ((probe-file "init.lsp") (load "init.lsp")))
  89.     (loop (setq tem *command-args*)
  90.           (cond ((setq tem (member "-load" tem :test 'equal))
  91.              (load (second tem) :verbose nil)
  92.              (setq tem (cddr tem))))
  93.           (or tem (return nil))))
  94.       (and (functionp *top-level-hook*)(funcall   *top-level-hook*)))
  95.  
  96.     (loop
  97.       (setq +++ ++ ++ + + -)
  98.       (if *no-prompt* (setq *no-prompt* nil)
  99.     (format t "~%~a>"
  100.         (if (eq *package* (find-package 'user)) ""
  101.                   (package-name *package*))))
  102.       (reset-stack-limits)
  103.       ;; have to exit and re-enter to multiply stacks
  104.       (cond (*multiply-stacks* (Return-from top-level)))
  105.       (when (catch *quit-tag*
  106.               (setq - (locally (declare (notinline read))
  107.                                (read *standard-input* nil *top-eof*)))
  108.               (when (eq - *top-eof*) (bye))
  109.               (let ((values (multiple-value-list
  110.                              (locally (declare (notinline eval)) (eval -)))))
  111.                 (setq /// // // / / values *** ** ** * * (car /))
  112.                 (fresh-line)
  113.                 (dolist (val /)
  114.                   (locally (declare (notinline prin1)) (prin1 val))
  115.                   (terpri))
  116.                 nil))
  117.         (setq *evalhook* nil *applyhook* nil)
  118.         (terpri *error-output*)
  119.         (break-current)))))
  120.  
  121.  
  122. (defun dbl-read (&optional (stream *standard-input*) (eof-error-p t)
  123.                (eof-value nil)  &aux tem  ch)
  124.   (tagbody
  125.    top
  126.    (setq ch (read-char stream eof-error-p eof-value))
  127.    (cond ((eql ch #\newline) (go top))
  128.      ((eq ch eof-value) (return-from dbl-read eof-value)))
  129.    (unread-char ch stream))
  130.  
  131.   (cond ((eql #\: ch)
  132.      (setq tem
  133.            (string-concatenate
  134.         "("
  135.         (read-line stream eof-error-p eof-value)")"))
  136.      (read  (make-string-input-stream tem)
  137.                      eof-error-p eof-value))
  138.     (t (read stream eof-error-p eof-value))))
  139.  
  140.  
  141. (defun break-level (at &optional env)
  142.   (let* ((*break-message* (if (stringp at) at *break-message*))
  143.      (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
  144.          (*quit-tag* (cons nil nil))
  145.          (*break-level* (if (not at) *break-level* (cons t *break-level*)))
  146.          (*ihs-base* (1+ *ihs-top*))
  147.          (*ihs-top* (1- (ihs-top)))
  148.          (*current-ihs* *ihs-top*)
  149.          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
  150.          (*frs-top* (frs-top))
  151.          (*break-env* nil)
  152.      (be *break-enable*)
  153.      (*break-enable*
  154.       (progn 
  155.         (if (stringp at) nil be)))
  156.                     ;(*standard-input* *terminal-io*)
  157.          (*readtable* (or *break-readtable* *readtable*))
  158.          (*read-suppress* nil)
  159.          (+ +) (++ ++) (+++ +++)
  160.          (- -)
  161.          (* *) (** **) (*** ***)
  162.          (/ /) (// //) (/// ///)
  163.          )
  164.                     ; (terpri *error-output*)
  165.     (unless (or be (not (stringp at)))
  166.       (simple-backtrace)
  167.       (break-quit (length (cdr *break-level*))))
  168.     (catch-fatal 1)
  169.     (setq *interrupt-enable* t)
  170.     (cond ((stringp at) (set-current)(terpri *error-output*)
  171.        (setq *no-prompt* nil)
  172.        )
  173.       (t (set-back at env)))
  174.       (loop 
  175.        (setq +++ ++ ++ + + -)
  176.        (cond (*no-prompt* (setq *no-prompt* nil))
  177.          (t
  178.           (format *debug-io* "~&~a~a>~{~*>~}"
  179.               (if (stringp at) "" "dbl:")
  180.               (if (eq *package* (find-package 'user)) ""
  181.             (package-name *package*))
  182.               *break-level*)))
  183.        (when
  184.     (catch 'step-continue
  185.         (catch *quit-tag*
  186.           (setq - (locally (declare (notinline read))
  187.                (dbl-read *debug-io* nil *top-eof*)))
  188.           (when (eq - *top-eof*) (bye))
  189.           (let* ( break-command
  190.          (values
  191.           (multiple-value-list
  192.           (LOCALLY (declare (notinline break-call evalhook))
  193.                (if (keywordp -)(setq - (cons - nil)))
  194.                (cond ((and (consp -) (keywordp (car -)))
  195.                   (setq break-command t)
  196.                   (break-call (car -) (cdr -)))
  197.                  (t (evalhook - nil nil *break-env*)))))))
  198.         (and break-command (eq (car values) :resume )(return))
  199.             (setq /// // // / / values *** ** ** * * (car /))
  200.             (fresh-line *debug-io*)
  201.             (dolist (val /)
  202.             (locally (declare (notinline prin1)) (prin1 val *debug-io*))
  203.             (terpri *debug-io*)))
  204.           nil))
  205.         (terpri *debug-io*)
  206.         (break-current))))))
  207.  
  208. (defvar *debug-print-level* 3)
  209.  
  210. (defun warn (format-string &rest args)
  211.   (let ((*print-level* 4)
  212.         (*print-length* 4)
  213.         (*print-case* :upcase))
  214.     (cond (*break-on-warnings*
  215.            (apply #'break format-string args))
  216.           (t (format *error-output* "~&Warning: ")
  217.              (let ((*indent-formatted-output* t))
  218.                (apply #'format *error-output* format-string args))
  219.              nil))))
  220.  
  221. (defun universal-error-handler
  222.   (error-name correctable function-name
  223.    continue-format-string error-format-string
  224.    &rest args &aux message)
  225.   (declare (ignore error-name))
  226.   (let ((*print-pretty* nil)
  227.         (*print-level* *debug-print-level*)
  228.         (*print-length* *debug-print-level*)
  229.         (*print-case* :upcase))
  230.        (terpri *error-output*)
  231.        (cond ((and correctable *break-enable*)
  232.               (format *error-output* "~&Correctable error: ")
  233.               (let ((*indent-formatted-output* t))
  234.                 (apply 'format *error-output* error-format-string args))
  235.               (terpri *error-output*)
  236.               (setq message (apply 'format nil error-format-string args))
  237.               (if function-name
  238.                   (format *error-output*
  239.                           "Signalled by ~:@(~S~).~%" function-name)
  240.                   (format *error-output*
  241.                           "Signalled by an anonymous function.~%"))
  242.               (format *error-output* "~&If continued: ")
  243.               (let ((*indent-formatted-output* t))
  244.                 (format *error-output* "~?~&" continue-format-string args))
  245.               )
  246.              (t
  247.               (format *error-output* "~&Error: ")
  248.               (let ((*indent-formatted-output* t))
  249.                 (apply 'format *error-output* error-format-string args))
  250.               (terpri *error-output*)
  251.           (if (> (length *link-array*) 0)
  252.           (format *error-output* "Fast links are on: do (use-fast-links nil) for debugging~%"))
  253.               (setq message (apply 'format nil error-format-string args))
  254.               (if function-name
  255.                   (format *error-output*
  256.                           "Error signalled by ~:@(~S~).~%" function-name)
  257.                   (format *error-output*
  258.                           "Error signalled by an anonymous function.~%")))))
  259.   (break-level message)
  260.   (unless correctable (throw *quit-tag* *quit-tag*)))
  261.  
  262. (defun break (&optional format-string &rest args &aux message)
  263.   (let ((*print-pretty* nil)
  264.         (*print-level* 4)
  265.         (*print-length* 4)
  266.         (*print-case* :upcase))
  267.        (terpri *error-output*)
  268.     (cond (format-string
  269.            (format *error-output* "~&Break: ")
  270.            (let ((*indent-formatted-output* t))
  271.              (apply 'format *error-output* format-string args))
  272.            (terpri *error-output*)
  273.            (setq message (apply 'format nil format-string args)))
  274.           (t (format *error-output* "~&Break.~%")
  275.              (setq message ""))))
  276.   (let ((*break-enable* t)) (break-level message))
  277.   nil)
  278.  
  279. (defun terminal-interrupt (correctablep)
  280.   (let ((*break-enable* t))
  281.     (if correctablep
  282.         (cerror "Type :r to resume execution, or :q to quit to top level."
  283.         "Console interrupt.")
  284.         (error "Console interrupt -- cannot continue."))))
  285.  
  286.  
  287. (defun break-call (key args &aux (fun (get key 'break-command)))
  288.   (if fun
  289.       (evalhook (cons fun args) nil nil *break-env*)
  290.       (format *debug-io* "~&~S is undefined break command.~%" key)))
  291.  
  292. (defun break-quit (&optional (level 0)
  293.                    &aux (current-level (length *break-level*)))
  294.   (when (and (>= level 0) (< level current-level))
  295.     (let ((x (nth (- current-level level 1) *quit-tags*)))
  296.       (throw (cdr x) (cdr x))))
  297.   (break-current))
  298.  
  299. (defun break-previous (&optional (offset 1))
  300.   (do ((i (1- *current-ihs*) (1- i)))
  301.       ((or (< i *ihs-base*) (<= offset 0))
  302.        (set-env)
  303.        (break-current))
  304.     (when (ihs-visible i)
  305.       (setq *current-ihs* i)
  306.       (setq offset (1- offset)))))
  307.  
  308. (defun set-current ()
  309.   (do ((i *current-ihs* (1- i)))
  310.       ((or (ihs-visible i) (<= i *ihs-base*))
  311.        (setq *current-ihs* i)
  312.        (set-env)
  313.        (format *debug-io* "Broken at ~:@(~S~).~:[  Type :H for Help.~;~]"
  314.                (ihs-fname *current-ihs*)
  315.                (cdr *break-level*)))))
  316.  
  317. (defun break-next (&optional (offset 1))
  318.   (do ((i *current-ihs* (1+ i)))
  319.       ((or (> i *ihs-top*) (< offset 0))
  320.        (set-env)
  321.        (break-current))
  322.     (when (ihs-visible i)
  323.       (setq *current-ihs* i)
  324.       (setq offset (1- offset)))))
  325.  
  326. (defun break-go (ihs-index)
  327.   (setq *current-ihs* (min (max ihs-index *ihs-base*) *ihs-top*))
  328.   (if (ihs-visible *current-ihs*)
  329.       (progn (set-env) (break-current))
  330.       (break-previous)))
  331.  
  332. (defun break-message ()
  333.   (princ *break-message* *debug-io*)
  334.   (terpri *debug-io*)
  335.   (values))
  336.  
  337. (defun describe-environment (&optional (env *break-env*) (str *debug-io*))
  338.   (or (eql (length env) 3) (error "bad env"))
  339.     (let ((fmt "~a~#[none~;~S~;~S and ~S~
  340.          ~:;~@{~#[~;and ~]~S~^, ~}~].~%"))
  341.       (apply 'format str fmt "Local variables: "
  342.          (mapcar #'car (car *break-env*)))
  343.       (apply 'format str fmt "Local functions: "
  344.          (mapcar #'car (cadr *break-env*)))
  345.       (apply 'format str fmt "Local blocks: "
  346.          (mapcan #'(lambda (x) (when (eq (cadr x) 'block) (list (car x))))
  347.                  (caddr *break-env*)))
  348.       (apply 'format str fmt "Local tags: "
  349.          (mapcan #'(lambda (x) (when (eq (cadr x) 'tag) (list (car x))))
  350.                  (caddr *break-env*)))))
  351.  
  352. (defun break-vs (&optional (x (ihs-vs *ihs-base*)) (y (ihs-vs *ihs-top*)))
  353.   (setq x (max x (ihs-vs *ihs-base*)))
  354.   (setq y (min y (1- (ihs-vs (1+ *ihs-top*)))))
  355.   (do ((ii *ihs-base* (1+ ii)))
  356.       ((or (>= ii *ihs-top*) (>= (ihs-vs ii) x))
  357.        (do ((vi x (1+ vi)))
  358.            ((> vi y) (values))
  359.          (do ()
  360.              ((> (ihs-vs ii) vi))
  361.            (when (ihs-visible ii) (print-ihs ii))
  362.            (incf ii))
  363.          (format *debug-io* "~&VS[~d]: ~s" vi (vs vi))))))
  364.  
  365. (defun break-local (&optional (n 0) &aux (x (+ (ihs-vs *current-ihs*) n)))
  366.   (break-vs x x))
  367.  
  368. (defun break-bds (&rest vars &aux (fi *frs-base*))
  369.   (do ((bi (1+ (frs-bds (1- *frs-base*))) (1+ bi))
  370.        (last (frs-bds (1+ *frs-top*))))
  371.       ((> bi last) (values))
  372.     (when (or (null vars) (member (bds-var bi) vars))
  373.       (do ()
  374.           ((or (> fi *frs-top*) (> (frs-bds fi) bi)))
  375.         (print-frs fi)
  376.         (incf fi))
  377.       (format *debug-io* "~&BDS[~d]: ~s = ~s"
  378.               bi (bds-var bi) (bds-val bi)))))
  379.  
  380. (defun simple-backtrace ()
  381.   (princ "Backtrace: " *debug-io*)
  382.   (do* ((i *ihs-base* (1+ i))
  383.         (b nil t))
  384.        ((> i *ihs-top*) (terpri *debug-io*) (values))
  385.     (when (ihs-visible i)
  386.       (when b (princ " > " *debug-io*))
  387.       (write (ihs-fname i) :stream *debug-io* :escape t
  388.              :case (if (= i *current-ihs*) :upcase :downcase)))))
  389.  
  390. (defun ihs-backtrace (&optional (from *ihs-base*) (to *ihs-top*))
  391.   (setq from (max from *ihs-base*))
  392.   (setq to (min to *ihs-top*))
  393.   (do* ((i from (1+ i))
  394.         (j (or (sch-frs-base *frs-base* from) (1+ *frs-top*))))
  395.        ((> i to) (values))
  396.     (when (ihs-visible i) (print-ihs i))
  397.     (do () ((or (> j *frs-top*) (> (frs-ihs j) i)))
  398.       (print-frs j)
  399.       (incf j))))
  400.  
  401. (defun print-ihs (i &aux (*print-level* 2) (*print-length* 4))
  402.   (format t "~&~:[  ~;@ ~]IHS[~d]: ~s ---> VS[~d]"
  403.           (= i *current-ihs*)
  404.           i
  405.           (let ((fun (ihs-fun i)))
  406.             (cond ((or (symbolp fun) (compiled-function-p fun)) fun)
  407.                   ((consp fun)
  408.                    (case (car fun)
  409.                      (lambda fun)
  410.                      ((lambda-block lambda-block-expanded) (cdr fun))
  411.                      (lambda-closure (cons 'lambda (cddddr fun)))
  412.                      (lambda-block-closure (cddddr fun))
  413.                      (t (cond
  414.              ((and (symbolp (car fun))
  415.                    (or (special-form-p(car fun))
  416.                    (fboundp (car fun))))
  417.               (car fun))
  418.              (t '(:zombi))))))
  419.                   (t (print fun)
  420.            :zombi)))
  421.           (ihs-vs i)))
  422.  
  423. (defun print-frs (i)
  424.   (format *debug-io* "~&    FRS[~d]: ~s ---> IHS[~d],VS[~d],BDS[~d]"
  425.           i (frs-kind i) (frs-ihs i) (frs-vs i) (frs-bds i)))
  426.  
  427. (defun frs-kind (i &aux x)
  428.   (case (frs-class i)
  429.     (:catch
  430.      (if (spicep (frs-tag i))
  431.          (or (and (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2))
  432.                                   :key #'caddr :test #'eq))
  433.                   (if (eq (cadar x) 'block)
  434.                       `(block ,(caar x) ***)
  435.                       `(tagbody ,@(reverse (mapcar #'car
  436.                                              (remove (frs-tag i) x
  437.                                                      :test-not #'eq
  438.                                                      :key #'caddr)))
  439.                                 ***)))
  440.              `(block/tagbody ,(frs-tag i)))
  441.          `(catch ',(frs-tag i) ***)))
  442.     (:protect '(unwind-protect ***))
  443.     (t `(system-internal-catcher ,(frs-tag i)))))
  444.  
  445. (defun break-current ()
  446.   (if *break-level*
  447.       (format *debug-io* "Broken at ~:@(~S~)." (ihs-fname *current-ihs*))
  448.       (format *debug-io* "~&Top level."))
  449.   (values))
  450.  
  451.  
  452.  
  453. (defvar *break-hidden-packages* nil)
  454.  
  455. (defun ihs-visible (i &aux (tem (ihs-fname i)))
  456.   (and tem (not (member tem *break-hidden-packages*))))
  457.  
  458.  
  459. (defun ihs-fname (ihs-index)
  460.   (let ((fun (ihs-fun ihs-index)))
  461.     (cond ((symbolp fun) fun)
  462.           ((consp fun)
  463.            (case (car fun)
  464.              (lambda 'lambda)
  465.              ((lambda-block lambda-block-expanded) (cadr fun))
  466.              (lambda-block-closure (nth 4 fun))
  467.              (lambda-closure 'lambda-closure)
  468.              (t (if (and (symbolp (car fun))
  469.              (or (special-form-p (car fun))
  470.                  (fboundp (car fun))))
  471.             (car fun) :zombi)
  472.             )))
  473.           ((compiled-function-p fun)
  474.            (compiled-function-name fun))
  475.           (t :zombi))))
  476.  
  477. (defun ihs-not-interpreted-env (ihs-index)
  478.   (let ((fun (ihs-fun ihs-index)))
  479.     (cond ((and (consp fun)
  480.         (> ihs-index 3)
  481.         ;(<= (ihs-vs ihs-index) (ihs-vs (- ihs-index 1)))
  482.         )
  483.        nil)
  484.       (t t))))
  485.  
  486. (defun set-env ()
  487.   (setq *break-env*
  488.         (if (ihs-not-interpreted-env *current-ihs*)
  489.             nil
  490.             (let ((i (ihs-vs *current-ihs*)))
  491.               (list (vs i) (vs (1+ i)) (vs (+ i 2)))))))
  492.  
  493. (defun list-delq (x l)
  494.   (cond ((null l) nil)
  495.         ((eq x (car l)) (cdr l))
  496.         (t (rplacd l (list-delq x (cdr l))))))
  497.  
  498. (defun super-go (i tag &aux x)
  499.   (when (and (>= i *frs-base*) (<= i *frs-top*) (spicep (frs-tag i)))
  500.     (if (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2))
  501.                         :key #'caddr :test #'eq))
  502.         ; Interpreted TAGBODY.
  503.         (when (and (eq (cadar x) 'tag)
  504.                    (member tag (mapcar #'car (remove (frs-tag i) x
  505.                                                      :test-not #'eq
  506.                                                      :key #'caddr))))
  507.           (internal-super-go (frs-tag i) tag t))
  508.         ; Maybe, compiled cross-closure TAGBODY.
  509.         ; But, it may also be compiled cross-closure BLOCK, in which case
  510.         ; SUPER-GO just RETURN-FROMs with zero values.
  511.         (internal-super-go (frs-tag i) tag nil)))
  512.   (format *debug-io* "~s is invalid tagbody identification for ~s." i tag))
  513.  
  514. (defun break-backward-search-stack (sym &aux string)
  515.   (setq string (string sym))
  516.   (do* ((ihs (1- *current-ihs*) (1- ihs))
  517.         (fname (ihs-fname ihs) (ihs-fname ihs)))
  518.       ((< ihs *ihs-base*)
  519.        (format *debug-io* "Search for ~a failed.~%" string))
  520.     (when (and (ihs-visible ihs)
  521.                (search string (symbol-name fname) :test #'char-equal))
  522.       (break-go ihs)
  523.       (return))))
  524.  
  525. (defun break-forward-search-stack (sym &aux string)
  526.   (setq string (string sym))
  527.   (do* ((ihs (1+ *current-ihs*) (1+ ihs))
  528.         (fname (ihs-fname ihs) (ihs-fname ihs)))
  529.       ((> ihs *ihs-top*)
  530.        (format *debug-io* "Search for ~a failed.~%" string))
  531.     (when (and (ihs-visible ihs)
  532.                (search string (symbol-name fname) :test #'char-equal))
  533.       (break-go ihs)
  534.       (return))))
  535.  
  536.  
  537. (putprop :b 'simple-backtrace 'break-command)
  538. (putprop :r '(lambda () :resume) 'break-command)
  539. (putprop :resume (get :r 'break-command) 'break-command)
  540. (putprop :bds 'break-bds 'break-command)
  541. (putprop :blocks 'break-blocks 'break-command)
  542. (putprop :bs 'break-backward-search-stack 'break-command)
  543. (putprop :c 'break-current 'break-command)
  544. (putprop :fs 'break-forward-search-stack 'break-command)
  545. (putprop :functions 'break-functions 'break-command)
  546. (putprop :go 'break-go 'break-command)
  547. (putprop :h 'break-help 'break-command)
  548. (putprop :help 'break-help 'break-command)
  549. (putprop :ihs 'ihs-backtrace 'break-command)
  550. (putprop :env '(lambda () (describe-environment *break-env*)) 'break-command)
  551. (putprop :m 'break-message 'break-command)
  552. (putprop :n 'break-next 'break-command)
  553. (putprop :p 'break-previous 'break-command)
  554. (putprop :q 'break-quit 'break-command)
  555. (putprop :s 'break-backward-search-stack 'break-command)
  556. (putprop :vs 'break-vs 'break-command)
  557.  
  558. (defun break-help ()
  559.   (format *debug-io* "
  560. Break-loop Command Summary ([] indicates optional arg)
  561. --------------------------
  562.  
  563. :bl [j]     show local variables and their values, or segment of vs if compiled
  564.               in j stack frames starting at the current one.
  565. :bt [n]     BACKTRACE [n steps]
  566. :down [i]   DOWN i frames (one if no i)
  567. :env        describe ENVIRONMENT of this stack frame (for interpreted).
  568. :fr [n]     show frame n
  569. :loc [i]    return i'th local of this frame if its function is compiled (si::loc i)
  570. :r          RESUME (return from the current break loop).
  571. :up [i]     UP i frames (one if no i)
  572.  
  573. Example: print a bactrace of the last 4 frames
  574.  
  575. >>:bt 4
  576.  
  577. Note:  (use-fast-links nil) makes all non system function calls
  578. be recorded in the stack.   (use-fast-links t) is the default
  579.  
  580. Low level commands:
  581. ------------------
  582. :p [i]           make current the i'th PREVIOUS frame (in list show by :b)
  583. :n [i]           make current the i'th NEXT frame (in list show by :b)
  584. :go [ihs-index]  make current the frame corresponding ihs-index
  585. :m               print the last break message.
  586. :c               show function of the current ihs frame.
  587. :q [i]           quit to top level
  588. :r               resume from this break loop.
  589. :b               full backtrace of all functions and special forms.
  590. :bs [name]       backward search for frame named 'name'
  591. :fs  [name]      search for frame named 'name'
  592. :vs [from] [to]  Show value stack between FROM and TO
  593. :ihs [from] [to] Show Invocation History Stack
  594. :bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1
  595.  
  596. ")
  597.       (values)
  598.       )
  599.  
  600.  
  601.  
  602.